home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / icon / contrib / treefox.lha / TREECAD.ICN < prev    next >
Encoding:
Text File  |  1993-04-24  |  30.1 KB  |  1,087 lines
  1. #############
  2. # TREECAD   #
  3. #############
  4. global  Lines, max, inter, out,
  5.         st, mlist, rstack, ustack, verbose, indx, optline,
  6.         mouseOK, paste, post, posting, insitu,
  7.         xattr, normattr, hiattr, nomode
  8.  
  9. procedure main(args)
  10.   if not(&features=="MS-DOS extensions") then {
  11.     writes("\nThis program requires a non-386 DOS ICON. ")
  12.     getch(); stop()
  13.   }
  14.   nomode := 0
  15.   normattr := 7
  16.   hiattr :=  15
  17.   xattr := char(78)||char(14)||char(6)||char(120)
  18.   st1 := " "
  19.   if *args>0 then {
  20.     while st1 ||:= get(args) || " "
  21.     if find("nomode",st1) then nomode:=1
  22.     st1 ? while tab(upto(&digits)) do {
  23.       normattr := tab(many(&digits))
  24.       hiattr := (move(1), tab(many(&digits)))
  25.       xattr := ""
  26.       every 1 to 4 do
  27.         xattr ||:= (move(1), char(tab(many(&digits))))
  28.       if *xattr~=4 then {
  29.         write("error in attr specs:", st1)
  30.         getch(); stop()
  31.       }
  32.     }
  33.   }
  34.   out := open("treecad.tmp","w")
  35.   ustack := []  # undo
  36.   rstack := []  # redo
  37.   max := 11
  38.   insitu:=0
  39.   if max <= 11 then optline := 23 else optline := 33
  40.   verbose := 0  # 0=no
  41.   st := ""
  42.   if initmouse()=65535 then {
  43.     mouseOK:=1
  44.   } else mouseOK:=0
  45.   indx := create seq(1,1)
  46.  
  47.   repeat {
  48.     clrscr(normattr)
  49.     qwrite(58,15,"       TREECAD",normattr)
  50.     qwrite(58,16," Tree Designer",normattr)
  51.     qwrite(58,17,"  M. Jahn 1993",normattr)
  52.     qwrite(1,optline-2,"                data                    system                action ",normattr)
  53.     qwrite(1,optline-1,"          ┌──────┼───────┐   ┌──────┬─────┴─────┬──────┐   ┌────┼──────┐",normattr)
  54.     repeat {
  55.       gotoXY(1,optline)
  56.       qwrite(1,optline,"          │corpus│scratch│   │max=  │verbose=   │tree= │   │quit│resume│ ",normattr)
  57.       qwrite(35,optline,string(max-1),normattr)
  58.       if verbose=0 then st1 := "OFF" else st1:="ON "
  59.       qwrite(46,optline,st1,normattr)
  60.       qwrite(55,optline,map(string(insitu),"01","bs"),normattr)
  61.       gotoXY(75,optline)
  62.       showmouse()
  63.       st1 := getaction(1)[3][1]  #1=act on getch
  64.       hidemouse()
  65.       if st1==("q"|"\e") then break break
  66.       if st1=="c" then {
  67.         if normattr=240 then system("SCROLLER.EXE treecad.in 192,206,240,48,112") else
  68.           system("SCROLLER.EXE treecad.in")
  69.         inp:=open("SCROLLER.DSK")
  70.         (st := read(inp)) | stop("nothing in SCROLLER.DSK")
  71.         if st[1]~=="(" then stop(st)
  72.         if match("exit",st) then stop()
  73.         st := "xxx," || st
  74.         close(inp); inp := &null
  75.         break
  76.       } else if st1=="s" then {
  77.           st:="xxx,(CP,CSp,(Cbar,C,IP)),(IP,NP,(Ibar,I,(VP,(Vbar,V,NP)))),"
  78.           break
  79.       } else if st1=="t" then {
  80.         if insitu=0 then insitu:=1 else insitu:=0
  81.         next
  82.       } else if st1=="m" then {
  83.          gotoXY(5,optline+1)
  84.          writes("Set maxlevels<3-≈15>: ")
  85.          oldmax:=max
  86.          max := read()+1
  87.          if max>16 then max := 16
  88.          gotoXY(5,optline+1); clreol(normattr)
  89.          if max>11 & oldmax<=11 then {
  90.            optline := 33
  91.            if nomode=0 then system("mode 80,43")
  92.            setY(1,336)
  93.            clrscr(normattr)
  94.          } else if max<=11 & oldmax>11 then {
  95.            optline := 23
  96.            if nomode=0 then system("mode 80,25")
  97.            setY(1,192)
  98.            clrscr(normattr)
  99.          }
  100.          next
  101.       } else if st1=="r" then {
  102.         if st=="" then next else break
  103.       } else if st1=="v" then {
  104.         if verbose=0 then verbose:=1 else verbose:=0
  105.         next
  106.       } else next
  107.     }
  108.     writ("st=", st)
  109.     #hidemouse()
  110.     clrscr(normattr)
  111.     if st1~=="r" then {
  112.       ustack := []  # undo
  113.       rstack := []  # redo
  114.       savetree(st)
  115.     }
  116.     hilight()
  117.     indx := ^indx
  118.   }
  119.   hidemouse()
  120.   if (max>11) & (nomode=0) then system("mode 80,25")
  121. end
  122.  
  123. procedure writ(L[])
  124.   if verbose=0 then fail
  125.   if not numeric(L[1]) then {
  126.     every writes(!L)
  127.     every writes(out,!L)
  128.   } else {
  129.     every writes(!L[2:0])
  130.     every writes(out,!L[2:0])
  131.   }
  132.   writes("\n",out,"\n")
  133.   if numeric(L[1]) then if getch()==("q"|"\e") then {
  134.     if (max>11) & (nomode=0) then system("mode 80,25")
  135.     stop()
  136.   }
  137. end
  138.  
  139. procedure getaction(N)
  140.   repeat {
  141.     if buttonpress(0)>0 then {
  142.       pos := getmousepos()
  143.       X:= (pos[1] / 8)+1
  144.       Y:= (pos[2] / 8)+1
  145.       if qread(X,Y)==" " then return [X,Y,""]
  146.       s := ""
  147.       hidemouse()
  148.       while any(~' /(│',qread(X-1,Y)) & (X>1) do X -:= 1
  149.       if Y=optline then {
  150.         every x:=1 to 79 do newattr(x,optline,normattr)
  151.         attr := hiattr
  152.       } else {
  153.         attr := readattr(X,Y)
  154.         if attr ~= normattr then attr:=normattr else attr := hiattr
  155.       }
  156.       x := X
  157.       repeat {
  158.         ch := qread(X,Y)
  159.         if any(' /)│',ch) then break else newattr(X,Y,attr)
  160.         s ||:= ch
  161.         if X < 79 then X+:=1 else break
  162.       }
  163.       showmouse()
  164.       return [x,Y, s]
  165.     } else if kbhit() then {
  166.       Y := whereXY()[2]
  167.       X := whereXY()[1]
  168.       if \N then return [X,Y, getch()]
  169.       s := readst(X,Y)
  170.       if type(s)~=="string" then return s
  171.       gotoXY(X,Y)
  172.       clreol(normattr)
  173.       return [X,Y, s]
  174.     }
  175.   }
  176. end
  177.  
  178. procedure readst(X,Y)
  179.   s := ""
  180.   repeat {
  181.     c:=getch()
  182.     case c of {
  183.       char(0): { s := movecursor(); break }
  184.       char(13): break
  185.       char(32): if *s=0 then s:=" " else {
  186.                   #while kbhit() do getch()
  187.                   break
  188.                 }
  189.       char(8):  if *s>0 then s := s[1:-1]
  190.       default:  s ||:= c
  191.     }
  192.     qwrite(X,Y,s||" ",normattr)
  193.     gotoXY(X+*s,Y)
  194.   }
  195.   return s
  196. end
  197.  
  198. procedure movecursor()
  199.   c := getch()
  200.   XY := whereXY()
  201.   gotoXY(10,12); X:=10; Y:=12
  202.   s := ""
  203.   repeat {
  204.     c := getch()
  205.     if c==(char(13)|" ") then {
  206.       x := X
  207.       repeat {
  208.         c := qread(X,Y)
  209.         if any(' /)│',c) then break
  210.         s ||:= c
  211.         if X < 79 then X+:=1 else break
  212.       }
  213.       gotoXY(XY[1],XY[2])
  214.       writes(s)
  215.       return [x,Y, s]
  216.     } else if c~==char(0) then break
  217.  
  218.     if c==char(0) & kbhit() then
  219.     case getch() of {
  220.       "t": { while any(~' ',qread(X,Y)) & (X<79) do gotoXY(X+:=1,Y)
  221.              while any(' │',qread(X,Y)) & (X<79) do gotoXY(X+:=1,Y)
  222.            }
  223.       "s": { while any(~' ',qread(X,Y)) & (X>1) do gotoXY(X-:=1,Y)
  224.              while any(' │',qread(X,Y)) & (X>1) do gotoXY(X-:=1,Y)
  225.              while any(~' ',qread(X-1,Y)) & (X>1) do gotoXY(X-:=1,Y)
  226.            }
  227.       "K": if X>1 then gotoXY(X-:=1,Y)
  228.       "M": if X<80 then gotoXY(X+:=1,Y)
  229.       "H": if Y>1 then gotoXY(X,Y-:=1)
  230.       "P": if Y<25 then gotoXY(X,Y+:=1)
  231.       "I": if Y>1 then gotoXY(X,Y:=1)
  232.       "Q": if Y<25 then gotoXY(X,Y:=25)
  233.     } #else break
  234.   }
  235.   gotoXY(XY[1],XY[2])
  236. end
  237.  
  238. procedure savetree(s)
  239.   push(ustack,s)
  240.   if *ustack>5 then pull(ustack)
  241. end
  242.  
  243. procedure hilight()
  244. local word, st1
  245.   menu := " │hi│cc│mc│gv│Gv│ │adj│mov│ │cpy│cut│gen│mir│ren│ │un│Re│sv│qu│ "
  246.   choice := "h"
  247.   showtree(st, " ",1) ## 1=gen.post
  248.   qwrite(1,optline-2,"        show         ops             edit            system ",normattr)
  249.   qwrite(1,optline-1," ┌──┬──┬─┴┬──┬──┐ ┌───┼───┐ ┌───┬───┬─┴─┬───┬───┐ ┌──┬──┼──┬──┐",normattr)
  250.             #menu := " │hi│cc│mc│gv│Gv│ │adj│mov│ │cpy│cut│gen│mir│ren│ │un│Re│sv│qu│ "
  251.   qwrite(1,optline,menu,normattr)
  252.   gotoXY(*menu+1,optline)
  253.   showmouse()
  254.   repeat {
  255.     word := getaction()
  256.     if word[2]=optline then { ## else treerange...
  257.       choice:=left(word[3],2)
  258.       word := ""
  259.       #writes(choice)
  260.       qwrite(*menu+1,optline,choice,normattr)
  261.     } else {  # keep choice and exec
  262.       if word[2]<=max*2-3 then {  # Y in tree display range ?
  263.         X := word[1]
  264.         Y := (word[2]+3)/2
  265.         XY := "," || X || "." || Y || "="
  266.         word := word[3]
  267.       } else {
  268.         choice=="  "; word:="";
  269.         gotoXY(*menu+1,optline)
  270.         next
  271.       }
  272.     }
  273.  
  274.     gotoXY(1,optline+1); clreol(normattr)
  275.     case choice of {
  276.       "  ": next
  277.       "mo": writes("MOVEALFA<node>: ")
  278.       "cc": writes("C-COMMAND<node>: ")
  279.       "cp": writes("COPY<node>: ")
  280.       "cu": writes("CUT<node>: ")
  281.       "ge": writes("GENERATE<node>: ")
  282.       "gv": writes("GOVERN<node>: ")
  283.       "Gv": writes("GOVERN: PATIENT:<node>: ")
  284.       "hi": writes("")
  285.       "ad": writes("ADJOIN<subtree>: ")
  286.       "mc": writes("M-COMMAND<node>: ")
  287.       "mi": writes("MIRROR<nonterminal>: ")
  288.       "qu": { hidemouse(); fail }
  289.       "re": writes("RENAME<node>: ")
  290.       "Re": writes("REDONE")
  291.       "sv": { writes("SAVED")
  292.              xf := open("treecad.in","a")
  293.              write(xf,st[5:0])
  294.              close(xf)
  295.              choice := "h"
  296.            }
  297.       "un": { writes("UNDONE")
  298.               push(rstack,st)
  299.               if *rstack>3 then pull(rstack)
  300.            }
  301.     }
  302.  
  303.     st1 := st
  304.     if find(choice, "cc,mc,gv,Gv,ad,mo,cp,cu,ge,mi,re") & (word=="") then {
  305.       word := getaction()
  306.       if word[2]<=max*2-3 then {  # Y in tree display range ?
  307.         X := word[1]
  308.         Y := (word[2]+3)/2
  309.         XY := "," || X || "." || Y || "="
  310.         word := word[3]
  311.       } else choice=="  "     # donothing
  312.     }
  313.     if type(word)~=="string" then choice:= "  "
  314.     if choice=="un" then {
  315.       if st := pop(ustack) then showtree(st,"undone",1)
  316.     } else if choice=="Re" then {
  317.       savetree(st)
  318.       if st := pop(rstack) then showtree(st,"redone",1)
  319.     } else if choice=="ad" then {
  320.       writes(word,XY, " TO<nonterminal>: ")
  321.       x := whereXY()[1]
  322.       repeat {
  323.         dest := getaction()
  324.         X := dest[1]
  325.         Y := (dest[2]+3)/2
  326.         dest := dest[3]
  327.         if dest=="" then break
  328.         (dpos := getnodepos(dest,"," || X || "." || Y || "=",st1)-1) | break
  329.         if st1[dpos]=="(" then {
  330.           writes(dest,XY)
  331.           savetree(st1)
  332.           #st := adjoin(word,XY,dest, "," || X || "." || Y || "=",st1)
  333.           st := adjoin(word,XY,dpos,st1)
  334.           showtree(st,"adjoined",1)
  335.           break
  336.         } else gotoXY(x,optline+1)
  337.       }
  338.     } else if choice=="mo" then {
  339.       writes(word, XY," TO<terminal>: ")
  340.       x := whereXY()[1]
  341.       repeat {
  342.         dest := getaction()
  343.         X := dest[1]
  344.         Y := (dest[2]+3)/2
  345.         dest := dest[3]
  346.         if dest=="" then break  ## null st = ESC
  347.         (dpos := getnodepos(dest,"," || X || "." || Y || "=",st1)) | break
  348.         if st1[dpos-1]~=="(" then {
  349.           writes(dest,XY)
  350.           savetree(st1)
  351.           st := movealfa(word,XY,dest,dpos,st1)
  352.           st := xchg(st,",,",",")
  353.           showtree(st,"Alfa-moved",1)
  354.           break
  355.         } else gotoXY(x,optline+1)
  356.       }
  357.     } else if choice=="cp" then {
  358.       writes(word, XY," TO<node>: ")
  359.       dest := getaction()
  360.       X := dest[1]
  361.       Y := (dest[2]+3)/2
  362.       dest := dest[3]
  363.       writes(dest,XY)
  364.       writ(1,"dest0=",dest)
  365.       savetree(st1)
  366.       st := cpy(word,XY,dest, "," || X || "." || Y || "=",st1)
  367.       showtree(st,"copied",1)
  368.     } else if choice=="cc" then {
  369.       writes(word,XY)
  370.       st1 := x_cmd(word,XY,st1,"c")
  371.       showtree(st1,"c-command",0)
  372.     } else if choice=="cu" then {
  373.       if *word>0 then {
  374.         savetree(st1)
  375.         st := expand(word,XY,"",st1)
  376.         showtree(st,"cut",1)
  377.       }
  378.     } else if choice=="ge" then {
  379.       writes(word,XY, " TO<head/paste/list>: ")
  380.       dest := getaction()[3]
  381.       if dest==" " then {
  382.         dest := paste; paste := ""
  383.         writes(left(dest,60))
  384.       }
  385.       savetree(st1)
  386.       st := expand(word,XY,dest,st1)
  387.       showtree(st,"expanded",1)
  388.     } else if choice=="mc" then {
  389.       writes(word,XY)
  390.       st1 := x_cmd(word,XY,st1,"m")
  391.       showtree(st1,"m-command",0)
  392.     } else if choice=="mi" then {
  393.       writes(word,XY)
  394.       savetree(st1)
  395.       st := mirror(word, XY, st1)
  396.       showtree(st,"mirrored",1)
  397.     } else if choice == "gv" then {
  398.       writes(word,XY)
  399.       st1 := x_cmd(word,XY,st1,"m")
  400.       st1 := govern(st1)
  401.       showtree(st1,"government",0)
  402.     } else if choice == "Gv" then {
  403.       writes(word,XY)
  404.       st1 := govern1(word,XY,st1)
  405.       showtree(st1,"passive government",0)
  406.     } else if choice == "re" then {
  407.       x := whereXY()[1]
  408.       writes(word,XY, " TO<string>: ")
  409.       repeat {
  410.         dest := readst(whereXY()[1],whereXY()[2])
  411.         if not find("(",dest) then {
  412.           savetree(st1)
  413.           st := Rename(word,XY,dest,st1)
  414.           showtree(st,"renamed",1)
  415.           break
  416.         } else gotoXY(x,optline+1)
  417.       }
  418.     }
  419.     qwrite(1,optline,menu,normattr)
  420.     gotoXY(1,optline+1); clreol(normattr)
  421.     gotoXY(1,optline+2); clreol(normattr)
  422.     gotoXY(*menu+1,optline)
  423.     while kbhit() do getch()
  424.   }
  425. end
  426.  
  427.  
  428. procedure cpy(source, sXY, dest, dXY, st1)
  429. local spos, dpos
  430.   writ("COPY:")
  431.   writ("st1=",st1)
  432.   (spos := getnodepos(source,sXY,st1)) | fail
  433.   if st1[spos-1]=="(" then spos-:=1
  434.   st1 ? if tab(spos) then source := tab(bal(',)'))
  435.   if (dest=="")  & find("(",source) then { # freefloat copies
  436.     if match(",1.",dXY) then dpos:=1 else dpos:=2
  437.     if dpos=1 then return "xxx," || source || "," || st1[5:0]  # add to left
  438.     else return st1 || source || ","
  439.   }
  440.   (dpos := getnodepos(dest,dXY,st1)) | fail
  441.   if st1[dpos-1]=="(" then dpos -:=1
  442.   st1 ? if tab(dpos) then dest := tab(bal(',)'))
  443.   writ("spos/dpos=", spos, " ", dpos)
  444.   writ("source=",source)
  445.   writ("dest=",dest)
  446.   st1 := st1[1:dpos] || source || st1[dpos+*dest:0]
  447.   writ(1,"st1=",st1)
  448.   return st1
  449. end
  450.  
  451. procedure getnodepos(word,XY,st1)
  452.   if integer(XY) then wpos:=XY else {
  453.     wpos := 0
  454.     post ? if tab(find(XY)) then {
  455.       =XY
  456.       wpos := tab(many(&digits))
  457.     }
  458.   }
  459.   if wpos>0 then return +wpos
  460. end
  461.  
  462. procedure x_cmd(word,XY,st1,cmdtype)
  463. ## m or c-command
  464.   if word=="" then fail
  465.   if integer(XY) then tpos:=XY else {
  466.     tpos := 0
  467.     post ? if tab(find(XY)) then {
  468.       =XY
  469.       tpos := tab(many(&digits))
  470.     }
  471.   }
  472.   writ("tpos=",tpos)
  473.   # flag word
  474.   st1 ? if tab(tpos) & ="(" then {
  475.     tab(find(","||word)+1)   ## else fail
  476.     tpos:=&pos
  477.   }
  478.   if tpos>0 then st1:=st1[1:tpos] || "°" || st1[tpos:0] else fail
  479.   writ("st1=",st1)
  480.   st1 := xchg(st1,"(","( ")
  481.   st1 := xchg(st1,",",", ")
  482.   st1 := xchg(st1," (","(")
  483.   word := " °" || word
  484.   #(xp := getnodepos(word, st1)) | fail
  485.   (xp := find(word,st1)) | fail
  486.   writ(1,"xp:0=",st1[xp:0])
  487.   st1 ? if tab(xp) then {
  488.     ##=","
  489.     move(-1)
  490.     xp := &pos
  491.     if any("(") then {   ## is a subtree
  492.       subtree :=  tab(bal(',)'))
  493.       subtree[2] := "!"
  494.       subtree := map(subtree," ","~")
  495.       #writ("subtree=", subtree)
  496.       st1 := st1[1:xp] || subtree || st1[xp+*subtree:0]
  497.     } else {   ## a terminal
  498.       move(1)
  499.       st1[&pos] := "!"
  500.       move(1)
  501.     }
  502.     &subject := st1
  503.     &pos := xp
  504.  
  505.     while move(-1) do {
  506.       xp := &pos
  507.       if st1[xp]=="(" then {
  508.         subtree := tab(bal(',)'))
  509.         if not find("!",subtree) then {
  510.           &pos := xp
  511.           next
  512.         }
  513.         subtree[2] := "~"
  514.         subtree := map(subtree," ","$")
  515.         #writ("subtree=", subtree)
  516.         st1 := st1[1:xp] || subtree || st1[xp+*subtree:0]
  517.         if (st1[xp+3] == "P") & (cmdtype=="m") then break
  518.         if find("$",subtree) & (cmdtype=="c") then break
  519.         &subject := st1
  520.         &pos := xp
  521.       }
  522.     }
  523.   }
  524.   st1 := xchg(st1," ","")
  525.   st1 := xchg(st1,"°","")
  526.   #writ(1,"ret st1=", st1)
  527.   return st1
  528. end
  529.  
  530. procedure mirror(source,XY, st1)
  531.   writ("source=",source)
  532.   if source~=="" then {
  533.     (spos := getnodepos(source, XY, st1)) | fail
  534.     if st1[spos-1]=="(" then spos-:=1 else fail
  535.   }
  536.   st1 ? if tab(spos) then source := tab(bal(',)'))
  537.   A:=B:=W:=newst:=""
  538.   source ? if ="(" then {
  539.     W := "(" || tab(upto(',')+1)
  540.     A := tab(bal(',)'))
  541.     move(1)
  542.     while B := tab(bal(',)')+1) do
  543.       if &pos < *source then newst ||:= B
  544.   }
  545.   if *A * *B * *W=0 then fail
  546.   B := B[1:-1] || ","
  547.   newst := W || B || newst || A || ")"
  548.   writ(1,"new=",newst)
  549.   return st1[1:spos] || newst || st1[spos+*source:0]
  550. end
  551.  
  552. procedure expand(source, XY, dest,st1)
  553.   writ("EXPAND")
  554.   writ("source=",source)
  555.   writ("XY/dest=",XY,dest)
  556.   if match(",1.",XY) then X:=1 else X:=2  #leftright
  557.   if X>1 & source~=="" then {
  558.     (spos := getnodepos(source, XY, st1)) | fail
  559.     if st1[spos-1]=="(" then spos-:=1
  560.     st1 ? if tab(spos) then source := tab(bal(',)'))
  561.   }
  562.  
  563.   if dest~=="" then {                # handle dest options
  564.     if not find("(",dest) then {
  565.       if dest[1]==" " then {    # ditto char [space]John; .A,B
  566.         dest := dest[2:0]
  567.         if any(~'(',source) then     # source=term?
  568.           dest:= "(" || source || "," || dest || ")" else  # (N,John)
  569.           dest:= source[1:-1] || "," || dest || ")"        # (NP,det,A,B)
  570.       }
  571.       else dest := map("(1P,1Sp,(1bar,1,YP))","1",dest[1])
  572.     }
  573.   }
  574.   writ(1,"st1=",st1)
  575.   if X=1 then return "xxx," || dest || "," || st1[5:0]  # add to left
  576.   if source=="" then return st1 || dest || ","
  577.   st1 ? if tab(spos) then {
  578.     paste := tab(bal(',)'))
  579.     if dest=="" then spos-:=1
  580.     st1 := st1[1:spos] || dest || tab(0)
  581.     if st1[spos+:2]==",)" then fail # cutting (A,x)
  582.   }
  583.   ## avoid ..(XP)..
  584.   st1 ? if tab(spos<-find("(")) & ="(" & tab(many(~',)')) & any(')') then {
  585.     st1[&pos]:=""
  586.     st1[spos]:=""
  587.   }
  588.   writ(1,"st1=",st1)
  589.   return st1
  590. end
  591.  
  592. procedure Rename(source,XY,dest,st1)
  593.   writ("RENAME:")
  594.   (spos := getnodepos(source, XY, st1)) | fail
  595.   st1 ? if tab(spos) then {
  596.     tab(find(source)) | fail
  597.     spos := &pos
  598.     tab(upto(',)'))
  599.     st1 := st1[1:spos] || dest || tab(0)
  600.   }
  601.   return st1
  602. end
  603.  
  604. procedure movealfa(source, sXY, dest, dpos, st1)
  605. local spos, x
  606.   writ("MOVEALFA:")
  607.   writ("st1=",st1)
  608.   (spos := getnodepos(source,sXY,st1)) | fail
  609.   if st1[spos-1]=="(" then spos-:=1
  610.   st1 ? if tab(spos) then source := tab(bal(',)'))
  611.   writ("spos/dpos=", spos, " ", dpos)
  612.   writ("source=",source)
  613.   writ(1,"dest=",dest)
  614.   ## chk move with/o trace: 1) whole trees 2) grabs
  615.   if source[1]=="(" then {
  616.     if find(".2=",sXY) | (dest=="?"||source[2:upto(',',source)]) then {
  617.       if dpos<spos then
  618.         return st1[1:dpos] || source || st1[dpos+*dest:spos] ||
  619.           st1[spos+*source:0]  else
  620.       if spos<dpos then
  621.         return st1[1:spos] || st1[spos+*source:dpos] || source ||
  622.           st1[dpos+*dest:0]  else fail
  623.     }
  624.   }
  625.   n := "#" || @indx
  626.   source ? if ="(" then newsource := "(" || tab(upto(',')) || n || tab(0) else
  627.     newsource := source || n
  628.   if dpos < spos then {
  629.     st1 := st1[1:dpos] || newsource || st1[dpos+*dest:spos] ||
  630.       n || st1[spos+*source:0]
  631.     until st1[-1]==")" do st1[-1]:=""
  632.   } else if spos < dpos then {
  633.     st1 := st1[1:spos] || n || st1[spos+*source:dpos] || newsource ||
  634.       st1[dpos+*dest:0]
  635.     until st1[-1]==")" do st1[-1]:=""
  636.   } else fail
  637.   st1 ||:= ","
  638.   writ(1,"st1=",st1)
  639.   return st1
  640. end
  641.  
  642.  
  643. procedure adjoin(source,sXY,dpos,st1)
  644. local spos, x, xpos
  645.   writ("ADJOIN:")
  646.   if *source = 0 then fail
  647.   (spos := getnodepos(source,sXY,st1)) | fail
  648.  
  649.   st1 ? while tab(xpos:=upto(',')+1) do {
  650.     x := tab(bal(','))
  651.     if &pos>spos then { source := x; spos:=xpos; break }
  652.   }
  653.   if /x then fail
  654.  
  655.   st1 ? if tab(dpos) then dest := tab(bal(',)'))
  656.   writ("spos/dpos=", spos, " ", dpos)
  657.   writ("source=",source)
  658.   writ(1,"dest=",dest)
  659.  
  660.   if find("(",dest) then {
  661.     oribar := dest
  662.     if spos > dpos then
  663.       newbar := oribar[1:upto(',',oribar)+1] || oribar || ",11)" else
  664.       newbar := oribar[1:upto(',',oribar)+1] || "11," || oribar || ")"
  665.     newbar := xchg(newbar,"11",source)
  666.     writ("oribar=",oribar)
  667.     writ("newbar=",newbar)
  668.   }
  669.   if spos>dpos then
  670.     st1 := st1[1:dpos] || newbar || st1[dpos+*dest:spos] ||
  671.       st1[spos+*source+1:0] else
  672.     st1 := st1[1:spos] || st1[spos+*source+1:dpos] || newbar ||
  673.       st1[dpos+*dest:0]
  674.   writ(1,"st1=",st1)
  675.   return st1
  676. end
  677.  
  678. procedure govern1(word,XY,st1)
  679.   if word=="" then fail
  680.  
  681.   (spos := getnodepos(word,XY,st1)) | fail
  682.   offs := 0
  683.   st1 ? if tab(spos) then {
  684.     tab(upto(',)'))
  685.     offs:=&pos
  686.   }
  687.  
  688.   st1 := st1[1:offs] || "²" || st1[offs:0]
  689.   writ(1,"st1/²=",st1)
  690.  
  691.   st1 ? while tab(spos:=upto('(')) do {
  692.     st0 := st1
  693.     if match("(P,"|"(V,"|"(I,"|"(N,") then {
  694.       XY := &pos+1
  695.       word := st1[XY]
  696.       writ(1,"word=",word)
  697.       guvcat := tab(bal(',)'))
  698.       writ(1,"guvcat=",guvcat)
  699.       if (word=="I") & find(",to)"|",+t0)", guvcat) then {
  700.         &pos:=spos+1; next
  701.       }
  702.       writ("word=",word)
  703.       writ(1,"st0=",st0)
  704.  
  705.       st0 := x_cmd(word,XY,st0,"m")
  706.       writ("st0 after mcmd=",st0)
  707.       st0 := govern(st0)
  708.       writ(1,"st0 after gov=",st0)
  709.       st0 ? while tab(upto('^')) do {
  710.         tab(many(~' ²,)'))
  711.         if any('²') then return xchg(st0,"²","")
  712.       }
  713.     }
  714.     &pos:=spos+1
  715.   }
  716. end
  717.  
  718. procedure govern(st1)
  719. local xp, xpos
  720.   writ(1,"gov.st1=", st1)
  721.   if find(("!I,~to"|"!I,~+t0"),st1) then return st1
  722.   st1 ? while tab(xpos:=upto('$')) do {
  723.     tab(upto('²,)'))
  724.     if st1[&pos-1]=="P" then {
  725.       &pos := xpos
  726.       st1[&pos] := "^"
  727.       if st1[&pos-1]=="(" then {
  728.         move(-1)
  729.         xp := tab(bal(',)'))
  730.         writ("xp=",xp)
  731.         # enter IP if..
  732.         if match("($IP",xp) & find("($I,$to)"|"($I,$+t0",xp) then move(-(*xp-2))
  733.         next
  734.       }
  735.     } else &pos:=xpos
  736.     move(2)
  737.   }
  738.   return st1
  739. end
  740.  
  741. procedure showtree(L, message, x)
  742.   write(out,L)
  743.   mlist := []
  744.   hidemouse()
  745.   L:="(" || L || ")"
  746.   if find(" ,"|",,",L) then {
  747.     L := xchg(L," ,",",")
  748.     L := xchg(L,",,",",")
  749.     #writes("error in treestring")
  750.     #getch()
  751.   }
  752.   Lines := []; inter := []
  753.   every 1 to max do {
  754.     ##Lines[i]:=""; inter[i]:=""
  755.     put(Lines,""); put(inter,"")
  756.   }
  757.   if x=0 then posting:=0 else {
  758.     posting := 1; post := ""
  759.   }
  760.   message := left(trim(message,":"),79)
  761.   handlelist(L,1,0)
  762.   postproc()
  763.   show()
  764.   showmouse()
  765.   #gotoXY(1,22); write(post);
  766.   #write(out,post)
  767. end
  768.  
  769. procedure show()
  770. local screenst
  771.   screenst := ""
  772.   every i:=2 to max do {
  773.     screenst ||:= left(map(Lines[i],".ⁿ·√","  .,"),80)
  774.     if i < max then screenst ||:= left(map(inter[i],"ⁿ.","  "), 80)
  775.     write(out,map(Lines[i],".ⁿ·√","  .,"))
  776.     write(out,map(inter[i],"ⁿ.","  "))
  777.   }
  778.   attr := char(normattr)
  779.   st1 := repl(attr,*screenst)
  780.   while attr := get(mlist) do {
  781.     xpos := get(mlist)
  782.     every i := xpos to xpos+(get(mlist)-1) do
  783.       st1[i] := attr
  784.   }
  785.   if verbose=1 then {
  786.     gotoXY(1,1)
  787.     write(screenst)
  788.     fail
  789.   }
  790.   st1 := map(st1,"!$~^",xattr)
  791.   screenst := collate(screenst, st1)
  792.   Poke([47104,0],screenst)
  793.   #if getch()=="q" then stop()
  794. end   # show
  795.  
  796.  
  797. procedure get_terms(tree)
  798. local st, x
  799.   st:=""
  800.   tree ? if tab(bal(',)')+1) then {
  801.     while x := tab(bal(',)')) do {
  802.       if x[1] ~== "(" then st ||:= x || "_"
  803.         else st ||:= get_terms(x[2:-1]||",")
  804.       move(1)
  805.     }
  806.   }
  807.   return st
  808. end
  809.  
  810. procedure handlelist(tree,n,tpos)
  811. local ccol, clen, cattr, xcol,xlen, xxattr,mempos
  812.   #writ(1,tpos)
  813.   tree ? if move(1) then {
  814.     (cat := tab(upto(','))) | { write("empty list:",tree[&pos:0])
  815.       read(); stop()}
  816.     catlen := 4
  817.     if any('$!~^',cat) then {
  818.       cattr := cat[1]
  819.       cat[1] := ""
  820.     } else cattr := ""
  821.     clen := *cat
  822.     if *cat<catlen then cat:=center(cat,catlen,"ⁿ") else catlen:=*cat
  823.     repeat {
  824.       move(1)
  825.       mempos := &pos-1
  826.       (x:=tab(bal(',)'))) | break
  827.       if (n>=(max-1)) & (x[1]=="(") then x:=get_terms(x[2:-1]||",")
  828.       if x[1]~=="(" then {
  829.         x:=trim(x,"_")
  830.         if any('$!~^',x) then {
  831.           xxattr := x[1]
  832.           x[1] := ""
  833.         } else xxattr := ""
  834.         xlen := *x
  835.         if *x<catlen then x:=center(x,catlen,"ⁿ")
  836.  
  837.         if insitu=1 then xline:=n+2 else xline := max
  838.         if xline> max then xline:=max
  839.         if *Lines[max]>*Lines[n+1] then {
  840.           Lines[n+1]:=left(Lines[n+1], *Lines[max], ".")
  841.           inter[n+1]:=left(inter[n+1], *Lines[max], ".")
  842.         }
  843.         a := "." || center("│",*x,"ⁿ") || "."
  844.         Lines[n+1] ||:= a
  845.         inter[n+1] ||:= a
  846.         if insitu=0 then
  847.         every i := n+2 to max-1 do {
  848.           Lines[i] := left(Lines[i], *Lines[n+1]- (*x+2)) || a
  849.           inter[i]:= left(inter[i], *Lines[n+1]- (*x+2),".") || a
  850.         }  else {
  851.            every i := n+2 to max do {
  852.              Lines[i]:=left(Lines[i], *Lines[n+1],".")
  853.              inter[i]:=left(inter[i], *Lines[n+1],".")
  854.            }
  855.         }
  856.         Lines[xline] := left(Lines[xline], *Lines[n+1]- (*x+2)) || "." || x || "."
  857.         if insitu=0 then inter[xline] := left(".", *Lines[xline])
  858.         xcol := *Lines[xline]-(*x+1)
  859.         Lines[xline] ? if move(xcol) then {
  860.           tab(many('.ⁿ'))
  861.           xcol := &pos
  862.         }
  863.         if posting=1 then
  864.           post ||:= "," || xcol || "." || xline || "=" || tpos+mempos
  865.         if *xxattr>0 then {
  866.           put(mlist,xxattr)
  867.           put(mlist,(xline-2)*160+xcol)
  868.           put(mlist,xlen)
  869.           xxattr := ""
  870.         }
  871.         #show("item")
  872.       } else  handlelist(x, n+1, tpos+mempos)
  873.     }
  874.     Lines[n+1] ? if move(*Lines[n]) then {
  875.       x:=tab(upto(~'.'))
  876.       Lines[n]||:= x; inter[n]||:=x
  877.     }
  878.     len:=*Lines[n]
  879.     x:= center("-", *trim(Lines[n+1],".")-len,"-")
  880.     Lines[n+1][len+1:0] ? while tab(a:=upto(~'.')) do {
  881.         if x[a]==("-") then {
  882.           tab(b:=many(~'.'))
  883.           b-:=1
  884.           mid :=a+integer((b-a)/2)
  885.           x[mid]:="!"
  886.         } else tab(b:=many(~'.'))
  887.       }
  888.     x:="." || x || "."
  889.     while a:=find(".-", x) do x[a+1]:="."
  890.     while a:=find("-.", x) do x[a]:="."
  891.     x:= x[2:-1]
  892.     inter[n]||:=x
  893.     (L:=find("!", x)) | (L:=10)
  894.     (R:=find("!.", x||".")) | (R:=10)
  895.     vor := left(".", L-1,".")
  896.     insert := center(cat,R-L+1,".")
  897.     if (R-L)>=*cat then {  # range of items
  898.       a:=upto(~'.',insert)-1
  899.       mid := len  + *vor + a+ integer((*cat+1)/2)
  900.       ccol := *Lines[n] + *vor
  901.       Lines[n] ||:= vor || insert
  902.       Lines[n] := left(Lines[n], *inter[n],".")
  903.       Lines[n] ? if move(ccol) then {
  904.         tab(many('.ⁿ'))
  905.         ccol := &pos
  906.       }
  907.       if posting=1 then post ||:= ","  || ccol || "." || n || "=" || tpos+1
  908.       if inter[n][mid]=="-" then inter[n][mid]:="t"
  909.         else inter[n][mid]:="+"
  910.       #show("RL-item")
  911.     } else {  # single item
  912.         if integer(*cat/2*2)=*cat then cat:="."||cat
  913.         #show("embedded list")
  914.         if inter[n][-1]~=="." then {
  915.           Lines[n]:=left(Lines[n],*inter[n]-(integer(*cat/2)+1),".")
  916.           ccol := *Lines[n]
  917.           Lines[n] ||:= cat
  918.           Lines[n] ? if move(ccol) then {
  919.             tab(many('.ⁿ'))
  920.             ccol := &pos
  921.           }
  922.           if posting=1 then post ||:= "," || ccol || "." || n || "=" || tpos+1
  923.         } else {
  924.             a:=*trim(Lines[n+1],".")-len
  925.             ccol := *Lines[n] + (a - *cat)/2
  926.             Lines[n] ||:= center(cat, a,".")
  927.             Lines[n] ? if move(ccol) then {
  928.               tab(many('.ⁿ'))
  929.               ccol := &pos
  930.             }
  931.             if posting=1 then post ||:= "," || ccol || "." || n || "=" || tpos+1
  932.             #show("single item")
  933.         }
  934.     } # if else
  935.     if *cattr>0 then {
  936.       put(mlist,cattr)
  937.       put(mlist,(n-2)*160+ccol)
  938.       put(mlist,clen)
  939.       cattr := ""
  940.     }
  941.   } #treescan
  942. end
  943.  
  944. procedure postproc()
  945. static rep1, rep2
  946.   initial {
  947.     rep1:=[".!.",".!", "-!.", "-!-", "t!", "!t",".+."]
  948.     rep2:=[".i.",".L", "-R.", "-T-", "tT", "Tt",".!."]
  949.   }
  950.   every i:= 2 to max do {
  951.     inter[i-1] := replace(inter[i-1]||".",rep1,rep2)
  952.     inter[i-1] := map(inter[i-1],"i!LRTt+-.","││┌┐┬┴┼─ ")
  953.   }
  954. end #postproc
  955.  
  956. procedure replace(subject, rep1, rep2)
  957.   every i:= 1 to *rep1 do subject := xchg(subject,rep1[i],rep2[i])
  958.   return subject
  959. end
  960.  
  961.  
  962. procedure xchg(s1,s2,s3)
  963. local result, i
  964.   result := ""
  965.   i := *s2
  966.   s1 ? {
  967.     while result ||:= tab(find(s2)) do {
  968.       result ||:= s3
  969.       move(i)
  970.     }
  971.     return result || tab(0)
  972.   }
  973. end
  974.  
  975. #### VIDEO ROUTINES ########
  976.  
  977. procedure collate(s1,s2)
  978. # ex ICON PROG LIBRARY
  979.    local length, ltemp, rtemp
  980.    static llabels, rlabels, clabels, blabels, half
  981.    initial {
  982.       llabels := "ab"
  983.       rlabels := "cd"
  984.       blabels := llabels || rlabels
  985.       clabels := "acbd"
  986.       half := 2
  987.       ltemp := left(&cset,*&cset / 2)
  988.       rtemp := right(&cset,*&cset / 2)
  989.       clabels := collate(ltemp,rtemp)
  990.       llabels := ltemp
  991.       rlabels := rtemp
  992.       blabels := string(&cset)
  993.       half := *llabels
  994.       }
  995.    length := *s1
  996.    if length <= half then
  997.       return map(left(clabels,2 * length),left(llabels,length) ||
  998.          left(rlabels,length),s1 || s2)
  999.    else return map(clabels,blabels,left(s1,half) || left(s2,half)) ||
  1000.       collate(right(s1,length - half),right(s2,length - half))
  1001. end
  1002.  
  1003.  
  1004. procedure gotoXY(X, Y)
  1005. local dx
  1006.   X -:= 1;  Y-:=1  # 0,0 = upper left for int 10
  1007.   dx := Y * 256 + X
  1008.   Int86([16,512,0,0,dx,0,0,0,0])
  1009. end
  1010.  
  1011. procedure clrscr(attr)
  1012.   Poke([47104, 0], repl(" "||char(attr), 4000))
  1013. end
  1014.  
  1015. procedure newattr(x,y,attr)
  1016. local offset
  1017.   offset := 2*((y-1)*80 + (x - 1))+1
  1018.   Poke([47104,offset],char(attr))
  1019. end
  1020.  
  1021. procedure qread(x,y)
  1022. # read the char at screen position x,y
  1023. local offset
  1024.   offset:= 2* ((y-1)*80+(x-1))
  1025.   return Peek([47104, offset],1)
  1026. end
  1027.  
  1028. procedure readattr(x,y)
  1029. # read the attr at screen position x,y
  1030. local offset
  1031.   offset:= 2* ((y-1)*80+(x-1)) + 1
  1032.   return ord(Peek([47104, offset],1))
  1033. end
  1034.  
  1035. procedure qwrite(x, y, s1, attr)
  1036.   s1 := collate(s1, repl(char(attr), *s1))
  1037.   offset := 2*((y-1)*80 + (x - 1))
  1038.   Poke([47104,offset],s1)
  1039. end
  1040.  
  1041. procedure clreol(attr)
  1042. local x, y, offset, s
  1043.   x := whereXY()[1];  y := whereXY()[2]
  1044.   offset := 2*((y-1)*80 + (x - 1))
  1045.   s := repl(" "||char(attr), 81-x)
  1046.   Poke([47104,offset],s)
  1047. end
  1048.  
  1049. procedure whereXY()
  1050. local dx
  1051.   dx := Int86([16,768,0,0,0,0,0,0,0])[5]
  1052.   return [ (dx % 256)+1, (dx / 256)+1 ]
  1053. end
  1054.  
  1055.  
  1056. ### MOUSE ####
  1057.  
  1058. procedure setY(min,max)
  1059. # vertical limits for mouse moves
  1060.   Int86([51, 8,0,min,max, 0,0,0,0])
  1061. end
  1062.  
  1063. procedure initmouse()
  1064.   return Int86([51, 0,0,0,0, 0,0,0,0])[2]
  1065. end
  1066.  
  1067.  
  1068. procedure showmouse()
  1069.   Int86([51,1,0,0,0,0,0,0,0])
  1070. end
  1071.  
  1072. procedure hidemouse()
  1073.   Int86([51,2,0,0,0,0,0,0,0])
  1074. end
  1075.  
  1076. procedure getmousepos()
  1077. local a
  1078. static L
  1079. initial L := [51,3,0,0,0,0,0,0,0]
  1080.   a := Int86(L)
  1081.   return [ a[4], a[5], a[3]]
  1082. end
  1083.  
  1084. procedure buttonpress(button)
  1085.   return Int86([51, 5,button,0,0, 0,0,0,0])[3]
  1086. end
  1087.